perm filename PPSRT.F4[1,MUS] blob
sn#079051 filedate 1973-12-21 generic text, type T, neo UTF8
00100 C SUBRS. ALPHA, RHORZ, SLUR, LOOP, PLTSRT, LINES, RDRAW
00200
00300 C****** FOR LISTS OF LETTERS, ETC. *******
00400 SUBROUTINE ALPHA
00500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00600 EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
00700 1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
00800 1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
00900 COMMON/STF/RSTFAC(8),RSTJC
01000
01100 IF(JA.EQ.20)GO TO 20
01300 JA=5
01400 54 R=19.7*RJE*RSTJC
01500 J=R
01600 RND=R-J
01700 R=0
01800 DO 50 KA=4,6
01900 JY=RJQ(KA)*100.+.2
02000 JX=1000000
02100 DO 53 LA=1,4
02200 JF=JY/JX
02400 IF(JF.NE.47.AND.JF.LT.90)CALL NOTWRT
02500 C 47=BLANK (WAS 99)
02600 JY=JY-JF*JX
02700 JB=JB+J
02800 R=R+RND
02900 IF(R.LT.1.0)GO TO 53
03000 JB=JB+1
03100 R=R-1.0
03200 53 JX=JX/100
03300 50 CONTINUE
03400 RETURN
03500 C FOR TRILLS
03600 20 R=RJB
03700 C R SAVES RJB(WHICH GETS CLOBBERED WHEN 'TR' IS WRITTEN.)
03800 C 20, POS1, STF, NT#, 0, POS2, X IF X=1 THEN NO WAVEY LINE
03900 RJE=.65
04000 JE=0
04100 JA=5
04200 JF=29
04300 C DRAWS T
04400 CALL NOTWRT
04500 JF=27
04600 C DRAWS R
04700 JB=JB+11*RSTJC
04800 51 CALL NOTWRT
04900 IF(JG.NE.0)RETURN
05000 JB=JB+16*RSTJC
05100 C RETURN IF NO WAVY LINE IS NEEDED
05200 JA=4
05300 RJB=R+4.*RSTJC
05400 JG=-2
05500 C JG IS SWITCH TO DRAW WIGGLE
05600 RJE=RJD+.8
05700 CALL ITMSUB
05800 END
05900
06000 FUNCTION RHORZ(R)
06100 RHORZ=R*5.96-596.
06200 END
06300
06400
06500 SUBROUTINE SLUR
06600 IMPLICIT INTEGER(A-Q,T-Z)
06700 REAL CENTR,PWDS
06800 COMMON /XRN/RN(4000) /PLTR/PLT,RHT,DIS
06900 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
07000 COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(8),RSTJC
07100 EQUIVALENCE (RJG,RJQ(5)),(RJF,RJQ(4)),(JG,JQ(5)),
07200 1(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
07300 1,(JF,JQ(4)),(RJD,RJQ(2)),(RJE,RJQ(3)),(RF,RJQ(20))
07400 DIMENSION SLURX(53),SLURY(53),RSEQ(26)
07500 DATA RSEQ/70.0,64.0,59.0,53.9,49.0,44.1,40.0,35.8,32.0,28.2,
07600 1 25.0,21.8,19.0,16.3,14.0,11.9,10.0,8.4,6.8,5.3
07700 1 ,4.0,2.9,2.0,1.4,1.0,.07/
07800 IF(JA.NE.12)GO TO 2
07900 RA=5.96*RSTJC*RJE
08000 L=3
08100 IF(JG.LE.JF)JG=JG+360
08200 JH=6
08300 IF(PLT)JH=1
08400 DO 3 K=JF,JG,JH
08500 R=K
08600 CALL LINES(RJB+RA*SIND(R),CENTR+RA*COSD(R),L)
08700 3 L=2
08800 C JA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2
08900 RETURN
09000 2 JJ=1
09100 21 TWICE=0
09200 22 RST7=RSTJC*7.
09210 GO TO (5,6,7),JH+4
09216 GO TO 4
09222 5 R=32
09228 C AFTER DOTTED NOTE
09234 GO TO 8
09240 6 R=22
09246 C BETWEEN NOTES
09252 8 RX=-1.3
09258 GO TO 9
09264 7 R=7
09270 RX=RSTJC
09276 9 RJB=RJB+R*RSTJC
09282 RJF=RJF+RX
09300 4 RXX=RHORZ(RJF)-RJB
09400 RTILT=(RJE-RJD)*RST7
09500 80 RX=SQRT(RXX**2+RTILT**2)
09600 1 R=CENTR
09700 IF(JH.GT.0)GO TO 180
09800 C FOR BRACKETS
09900 RB=RX/52.
10000 DO 81 K=1,53
10100 81 SLURX(K)=RB*(K-1)+RJB
10200 RA=-RJG*RST7
10300 R=R-RA
10400 RW=630.
10500 RB=RA/RW
10600 DO 82 K=1,26
10700 SLURY(K)=RW*RB+R
10800 SLURY(54-K)=SLURY(K)
10900 82 RW=RW-RSEQ(K)
11000 SLURY(27)=SLURY(26)
11100 L=53
11200
11300 89 IF(RTILT.EQ.0)GO TO 87
11500 RW=ATAN2(RTILT,RXX)
11600 RA=SIN(RW)
11700 RB=COS(RW)
11800 RZ=SLURX(1)
11900 RW=SLURY(1)
12000 DO 84 K=1,L
12100 SLURX(K)=SLURX(K)-RZ
12200 84 SLURY(K)=SLURY(K)-RW
12300 DO 83 K=1,L
12400 R=SLURX(K)
12500 SLURX(K)=RB*R-RA*SLURY(K)+RZ
12600 83 SLURY(K)=RB*SLURY(K)+RA*R+RW
12700
12800 87 CALL LINES(SLURX(JJ),SLURY(JJ),3)
12900 DO 88 K=JJ+1,L
13000 88 CALL LINES(SLURX(K),SLURY(K),2)
13100 IF(TWICE)RETURN
13200 TWICE=-1
13300 RJG=RJG+.1
13400 GO TO 1
13500 RETURN
13600 180 RW=R+RJG*RST7
13700 RX=RX+RJB
13800 RA=(RJE-RJD)*RST7
13900 SLURX(1)=RJB
14000 SLURY(1)=R
14100 SLURX(2)=RJB
14200 SLURY(2)=RW
14300 SLURX(3)=RX
14400 SLURY(3)=RW+RA
14500 SLURX(4)=RX
14600 SLURY(4)=R+RA
14700 L=4
14800 IF(JH.EQ.2)L=3
14900 IF(JH.EQ.3)JJ=2
15000 TWICE=-1
15100 GO TO 87
15200 END
15300 C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
15400 C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
15500
15600
15700 SUBROUTINE LOOP(I,J,K,L,M,N)
15800 DIMENSION N(1)
15900 DO 1 NN=I,J,K
16000 1 N(NN+L)=N(NN+M)
16100 END
16200
16300
16400 SUBROUTINE PLTSRT
16500 C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING.
16600 IMPLICIT INTEGER(S-Z)
16700 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
16800 DIMENSION P(250)
16900 DO 4 K=1,ITEM
17000 L=PWDS(K)
17020 A=RN(L+2)
17100 P(K)=A+1000*RN(L+3)
17150 4 IF(A.LT.0)P(K)=-10000
17175 C PLOTS ALL NEG. POSITIONS FIRST.
17200 Y=I
17400 2 A=P(1)
17500 L=1
17600 DO 1 K=1,ITEM
17700 IF(A.LE.P(K))GO TO 1
17800 A=P(K)
17900 L=K
18000 1 CONTINUE
18100 IF(A.EQ.10000.)RETURN
18200 C ALL ITEMS HAVE NOW BEEN SHUFFLED
18300 V=PWDS(L)
18400 P(L)=10000
18500 L=RN(V)+2
18600 CALL LOOP(0,L,1,Y,V,RN)
18700 Y=Y+L+1
18800 GO TO 2
18900 END
19000
19100
19200 SUBROUTINE LINES(A,B,L)
19300 COMMON /SIZ/RSZ,JCEN,KCEN /FL/IC,NZ,NX,RZ,XGP
19400 COMMON/DL/IXRX,SAVER,AA /PLTR/IPLT,RHT,DIS
19500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
19600 COMMON/DPY/IGO,RXGP,ITOP,IBOT
19700 DATA BB/260.0/,CC/3.5/,DD/1.43/,MX/512/,XGP/1200.0/
19800 C SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
19900 22 GO TO 23
20000 C CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
20100 24 AA=CC-DD*ABS(A)/BB
20200 C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
20300 B=B*AA
20400 23 IF(IPLT)GO TO 2
20500 M=A*RSZ
20600 N=B*RSZ
20660 3 IF(JA.EQ.44)GO TO 6
20700 K=B
20800 IF(K.GT.ITOP)ITOP=B
20900 IF(K.LT.IBOT)IBOT=B
21000 6 RETURN
21100 2 IF(IPLT.EQ.-2)RETURN
21200 C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
21300 IF(IXRX.EQ.0)GO TO 9
21400 M=ROFF(RXGP-B*RHT)
21500 N=ROFF(XGP+A*DIS)
21800 GO TO 8
22100 9 M=ROFF(A*DIS)
22200 N=ROFF(B*RHT)
22300 8 CALL PLOT(M,N,L)
22400 END
22500
22600 SUBROUTINE RDRAW(I,S,XY,X,RJB,CENTR,RMINI)
22700 C TO X,Y INTO ONE WORD
22800 DIMENSION XY(1)
22900 DO 2 K=I,IFIX(S)
23000 L=2
23100 Y=XY(K)
23200 IF(Y.LT.1000.)GO TO 3
23300 L=3
23400 Y=Y-1000.
23500 C >1000 = INVIS. LINE
23600 3 M=Y
23700 Y=(Y-M)*1000.
23800 IF(Y.GT.100.)Y=100-Y
23900 C Y NUMBERS .GT.100 ARE NEG.
24000 B=Y*X+CENTR
24100 IF(M.GT.60)M=100-M
24200 A=M*RMINI+RJB
24300 2 CALL LINES(A,B,L)
24400 END
24500
24600 FUNCTION IABS(N)
24700 IABS=N
24800 IF(N)IABS=-N
24900 END
25000
25100 BLOCK DATA
25200 IMPLICIT INTEGER(A-Q,S-Z)
25300 COMMON /NW/FILL(7),RNOTE(24)
25400 COMMON /NU/NUMQ(44),RNUMS(327),RACCI(32),NACCI(3)
25500 DATA FILL/4,5,6,6,6,5,4/,
25600 1 RNOTE/ 1000., .002, 2.005, 6.007, 10.007, 14.005, 16.002,
25700 1 16.102, 14.105, 10.107, 6.107, 2.105, .102, 0, 4.005, 11.006,
25800 1 1016., 12.105, 5.106, 1000.,7.007,14., 7.107, 0/,
25900 1 NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
26000 1,150,157,164,171,177,181,187,1,192,200,212,221,234,239,246
26100 1,250,256,261,266, 271,282,285,293,298,307,316,321/
26200 DATA (RNUMS(K),K=1,131)/10.0,1003.107, 6.102, 6.01, 3.015,
26300 1 104.015, 107.01,107.102, 104.107, 3.107,
26400 1 14.0, 1103.011, 1.015, 1.107, 22.0,
26500 1 1106.011, 102.015, 3.015, 7.011, 7.005, 107.107, 7.107, 32.0,
26600 1 1107.015, 7.015, 101.007, 3.007, 7.003, 7.102, 3.107, 103.107,
26700 1 107.103, 37.0, 1007.102, 107.102, 2.015, 2.107, 46.0, 1107.107,
26800 1 4.103, 7.0, 7.004, 2.006, 107.004, 107.015, 7.015, 56.0,
26900 1 1004.015, 107.0, 107.103, 103.107, 4.107, 7.103, 7.0, 3.003,
27000 1 104.003, 61.0, 1107.011, 107.015, 7.015, 107.107, 78.0, 1003.004,
27100 1 7.0, 7.103, 4.107, 104.107, 107.103, 107.0, 103.004, 3.004,
27200 1 6.008, 6.012, 2.015, 102.015, 106.012, 106.008, 103.004,
27300 1 88.0, 1104.107, 7.008, 7.011, 4.015, 104.015, 107.011, 107.008,
27400 1 103.005, 4.005, 94.0, 1106.107, 0.015,6.107,1004.101,104.101,
27500 1 107.0, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 1106.004,
27600 1 2.004, 6.001, 6.104, 3.107, 106.107, 116.0, 1006.104, 3.107,
27700 1 103.107, 106.104, 106.011, 103.015, 3.015, 6.011, 124.0,
27800 1 1106.107, 106.015, 3.015, 6.011, 6.103, 3.107, 106.107,
27900 1 131.0, 1006.107, 106.107, 106.015, 6.015, 1003.005, 106.005/
28000 C THE NEXT IS FOR 'F' TO 'P'
28100 C 1 NUM NOT NEEDED IN 'G' ALSO IN RNOTE (1/2 NOTE).
28200 DATA (RNUMS(K),K=132,199)/
28300 1 137.0, 1106.107, 106.015, 6.015, 1003.005, 106.005, 149.0,
28400 1 1001.102, 6.102, 6.104, 6.104, 3.107, 103.107, 106.104,
28500 1 106.011, 103.015, 3.015, 6.011, 156.0, 1106.107, 106.015,
28600 1 1006.015, 6.107, 1006.005, 106.005, 163.0, 1103.107,3.107,
28700 1 1000.107, 0.015, 1103.015, 3.015,
28800 1 170.0, 1106.102, 106.104, 103.107, 3.107, 6.104, 6.015,
28900 1 176.0, 1106.107, 106.015, 1006.015, 106.005, 6.107, 180.0,
29000 1 1006.107, 106.107, 106.015, 186.0, 1106.107, 106.015, 0.004,
29100 1 6.015, 6.107, 191.0, 1106.107, 106.015, 6.107, 6.015, 199.0
29200 1, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 106.004/
29300 C 'Q' TO ')'
29400 DATA(RNUMS(K),K=200,327)/
29500 1 211.0, 1003.107, 6.102, 6.01, 3.015, 103.015, 106.01, 106.102,
29600 1 103.107, 3.107, 1001.001, 7.108, 220.0, 1106.107, 106.015,
29700 1 3.015, 6.012, 6.007, 3.004, 106.004, 6.107, 233.0, 1106.104,
29800 1 103.107, 3.107, 6.104, 6.001, 3.004, 103.004, 106.007, 106.011,
29900 1 103.015, 3.015, 6.01, 238.0, 1106.015, 7.015, 1000.015, 0.107,
30000 1 245.0, 1106.015, 106.104, 103.107, 3.107, 6.104, 6.015, 249.0,
30100 1 1106.015, 0.107, 6.015, 255.0, 1106.015, 104.107, 0.005, 4.107,
30200 1 6.015, 260.0, 1106.015, 6.107, 1106.107, 6.015, 265.0, 1106.015,
30300 1 0.003, 1106.107, 6.015, 270.0, 1106.015, 6.015, 106.107, 6.107,
30400 1 281.0, 1101.102, 101.105, 1.105, .102, .105, 101.102, 1.102,
30500 1 1.108, 102.112, 1102.112, 284., 1106.004, 6.004, 292., 1101.102,
30600 1 101.105, 0.102, 0.105, 1.102, 1.105, 101.102, 297.0, 1106.008,
30700 1 6.008, 1106.001, 6.001, 306.0, 1003.015, 0.013, 102.009,
30800 1 103.007, 103.0, 102.101, 0.105, 3.107, 315.0, 1103.015, 0.013,
30900 1 2.009, 3.007, 3.0, 2.101, 0.105, 103.107, 320.0, 1106.004,
31000 1 6.004, 1000.01, 0.102, 327.0,1106.004, 6.004, 1003.009,
31100 1 103.101, 1003.101, 103.009/
31200
31300 C 1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS
31400 DATA RACCI/8.0,1114.003,111.007, 108.007, 106.003, 107.101
31500 1,114.108, 114.02, 21.0,1104.105, 118.109, 118.108,104.104
31600 1,1108.113, 108.016, 1104.008, 118.004, 118.005,104.009
31700 1,1114.014, 114.115, 32.0,1106.117, 106.007, 114.004
31800 1,114.004, 106.007, 1114.018, 114.107, 106.104, 106.103
31900 1,114.106/,NACCI/1,9,22/
32000 END
32100
32200 C ******* 7, POS, STF, NUM OF SHARPS OR FLATS (+ OR -), CLEF, HGT
32300 C ( CLEF = TREB,0 BASS,1 ALT,2 TEN,3 )
32400 SUBROUTINE KSIG
32500 C FOR KEY SIGNATURES AND ACCENTS, ETC. (IN 'SCORE')
32600 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/STF/RSTFAC(8),RSTJC
32700 EQUIVALENCE (RJD,RJQ(2)),(JD,JQ(2)),(JE,JQ(3)),(JF,JQ(4))
32800
32900 JA=6
33000 C USES THIS KEY NUM IN NOTWRT
33100 KN=0
33200 C COUNTER
33300 IZ=IABS(JD)
33400 C NUMBER OF CALLS ON NOTWRT
33500 C THE CLEF NUM. IT GETS WIPED OUT IN NOTWRT.
33600 JW=1
33700 IF(JD.GT.0)JW=2
33800 C THE CODE FOR FLAT OR SHARP
33900 5333 CLEF=-(JE+1)
34000 C CLEF #S ARE CHNGD TO -1,-2,-3,-4 (TREB.,BA.,ALT.,TEN.)
34100 C CLEF NOW SET IN MAIN PROG.
34200 C IF NO CLEF GIVEN, TREBLE IS USED.
34300 T=10.
34400 IF(CLEF.LT.-2.)T=11.
34500 S=CLEF+4.
34600 IF(CLEF.EQ.-4)S=-1.
34700 IF(JD.LT.0)GO TO 253
34800 W=-3.
34900 YY=4.
35000 Z=11.
35100 C SHARPS
35200 GO TO 353
35300 253 W=3.
35400 YY=-4.
35500 Z=7.
35600 C FLATS
35700 353 N=1
35800 RX=JB
35900 RA=0
36000 C RA IS AMOUNT TO BE ADDED TO ORIGINAL POS.
36100 DO 553 KA=1,IZ
36200 JE=JW
36300 JB=RX+RA
36400 RA=RA+13.*RSTJC
36500 C MOVES OVER FOR NEXT ACCI.
36600 RD=Z
36700 RJD=Z
36800 IF(CLEF.NE.-1.)GO TO 7
36900 IF(RJD.GT.12.)RJD=RJD-7.
37000 GO TO 9
37100 7 RJD=RJD-S
37200 IF(RJD.GT.T)RJD=RJD-7.
37300 C ABOVE ARRANGES VERT. POS OF ACCIS.
37400 9 JD=RJD
37500 CALL NOTWRT
37600 Z=RD+W
37700 IF(N)Z=RD+YY
37800 553 N=-N
37900 END
38000 SUBROUTINE NOIR(RMINI)
38100 C BLACKS IN NOTES
38200 COMMON/DL/IXRX,Q,AA
38300 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
38400 COMMON/PLTR/IPLT,RHT,DIS
38500 COMMON/DPY/IGO,RXGP,ITOP,IBOT
38600 EQUIVALENCE (JF,JQ(4))
38700 DATA IXGP/1200/,BL/7.4/,BH/6.5/,CX/1.0/,FL/0.0/
38800 C ADJUST BH AND FL FOR HEIGHT OF NOTE AND 'WIDTH'
38900 JXG=RXGP
39000 B=CENTR*RHT
39100 C=CX
39200 IF(B)C=-C
39300 KC=B+C
39400 D=RJB*DIS
39500 B=BH*RMINI*RHT
39600 A=BL*RMINI*DIS
39700 BX=.5
39800 IF(D)BX=-BX
39900 C=A+D+BX
40000 C ROUND-OFF MAY GIVE SMALL ERROR WHEN X COORD.=NEAR 0.
40100 A=A*A
40200 K=B+FL
40300 B=B*B
40400 C USES EQUATION FOR ELLIPSE
40500 N=1
40600 5 L=C
40700 JY=KC
40800 IF(IXRX.EQ.0)GO TO 4
40900 JY=IXGP+L
41000 L=JXG-KC
41100 4 CALL PLOT(L,JY,3)
41200 6 DO 1 J=-K,K
41300 Y=J*J
41400 JY=J+KC
41500 X=SQRT(A-(A*Y)/B)
41600 L=C-X
41700 M=C+X
41800 C THE TWO SIDES OF THE LINE
41900 JZ=JY
42000 IF(N)CALL EXCH(L,M)
42100 IF(IXRX.EQ.0)GO TO 3
42200 I=L
42300 L=JXG-JY
42400 JY=IXGP+I
42500 JZ=M
42600 M=L
42700 JZ=IXGP+JZ
42800 3 CALL PLOT(L,JY,2)
42900 CALL PLOT(M,JZ,2)
43000 1 N=-N
43100 END